(in-package :gwee)

(defvar *current-key* nil)

(defclass keymap ()
  ((parents :initform nil :initarg :parents :accessor keymap-parents)
   ;; XXX: there's a reason we don't want to use a hash here, but I can't remember why.
   (bindings :initform nil :initarg :bindings :accessor keymap-bindings)))

(defstruct binding
  key action)

(defun find-binding (kmap key)
  (or (find key (keymap-bindings kmap) :test 'equalp :key 'binding-key)
      (find t (keymap-bindings kmap) :key 'binding-key)))

(defun report-kbd-parse-error (c stream)
  (format stream "Failed to parse key string: ~s" (slot-value c 'string)))

(define-condition kbd-parse-error (error)
  ((string :initarg :string))
  (:report report-kbd-parse-error)
  (:documentation "Raised when a kbd string failed to parse."))

(defun parse-mods (mods end)
  "MODS is a sequence of <MOD CHAR> #\- pairs. Return a list suitable
for passing as the last argument to (apply #'make-key ...)"
  (unless (evenp end)
    (signal 'kbd-parse-error :string mods))
  (loop for i from 0 below end by 2
        if (char/= (char mods (1+ i)) #\-)
        do (signal 'kbd-parse-error :string mods)
        collect (case (char mods i)
		  (#\M :meta)
		  (#\A :alt)
		  (#\C :control)
		  (#\H :hyper)
		  (#\s :super)
		  (#\S :shift)
		  (t (signal 'kbd-parse-error :string mods)))))

(defun parse-key (string)
  "Parse STRING and return a key structure. Raise an error of type
kbd-parse if the key failed to parse."
  (let* ((p (when (> (length string) 2)
              (position #\- string :from-end t :end (- (length string) 1))))
         (mods (parse-mods string (if p (1+ p) 0)))
	 (sym-string (or (subseq string (if p (1+ p) 0))
			 (signal 'kbd-parse-error :string string)))
         (keysym (intern (format nil "SDL-KEY-~a" (string-upcase sym-string)) :keyword)))
    ;; handle upper case letters properly.
    (when (and (= (length sym-string) 1)
	       (alpha-char-p (char sym-string 0))
	       (upper-case-p (char sym-string 0)))
      (pushnew :shift mods))
    (make-key :sym keysym :mod mods)))

(defun parse-key-seq (keys)
  "KEYS is a key sequence. Parse it and return the list of keys."
  (mapcar 'parse-key (split-sequence:split-sequence #\Space keys)))

(defgeneric bind-key (kbap key action))

(defmethod bind-key (kmap (key string) action)
  (bind-key kmap (parse-key-seq key) action))

(defmethod bind-key ((kmap keymap) (key key) action)
  (let ((binding (find-binding kmap key)))
    (if binding
	(setf (binding-action binding) action)
	(push (make-binding :key key :action action)
	      (keymap-bindings kmap)))))

(defmethod bind-key ((kmap keymap) (key list) action)
  (let ((binding (find-binding kmap (car key))))
    (cond ((null key)
	   (error "hey key is NIL."))
	  ((= (length key) 1)
	   (bind-key kmap (car key) action))
	  ((typep (binding-action binding) 'keymap)
	   (bind-key (binding-action binding) (cdr key) action))
	  (t
	   (error "binding for ~a is not a keymap" (car key))))))

(defgeneric execute-key-action (context binding))

(defmethod execute-key-action ((context view) (action function))
  (funcall action context))

(defmethod execute-key-action ((context view) (action symbol))
  (funcall action context))

(defmethod execute-key-action ((context view) (action keymap))
  (let* ((key (block event
		(with-event-handler ()
		  (cond
		    ((match-event %event% :sdl-key-down-event)
		     (return-from event (parse-key-event %event%)))))))
	 (binding (find-binding action key)))
    ;; FIXME: some sort of feedback for unbound keys?
    (when binding
      (execute-key-action context (binding-action binding)))))

(defun keymap (&rest keys)
  "Return a fresh keymap with the specified key mappings"
  (make-instance 'keymap
                 :bindings (loop for i = keys then (cddr i) while i
                              collect (make-binding :key (if (stringp (first i))
                                                             (parse-key (first i))
                                                             (first i))
                                                    :action (second i)))))

(defmacro defkeymap (var documentation &rest keys)
  `(defvar ,var
     (make-instance 'keymap
		    :bindings (list ,@(loop for i = keys then (cddr i) while i
					 collect `(make-binding :key ,(if (stringp (first i))
									  (parse-key (first i))
									  (first i))
								:action ',(second i)
								))))
     ,documentation))
